Best of Shareware/Best of PC Windows Shareware 1.0 - Wayzata Technology (7111) (1993).iso/pc/dos/programg/decgif3/decgif3.bas

BASIC Source File | 1992-08-06 | 19KB | 665 lines

'*****************************************************************************
'* DECGIF.BAS- A PDS 7.1 & QB4.5 GIF Decompressor With Some Assembly
'* By Rich Geldreich 1992
'* You may use this program for anything you wish, as long as credit
'* is given where credit is due! Thanks.
'* 06-27-92, X Y Rescaler added 07-17-92
'*
'* To make this program compatible with QB4.5, use search and replace
'* to change all of the "SSEG" strings to "VARSEG" strings in this module.
'*
'*
'* The module USEDGIF.BAS demonstrates this program.
'*
'* Any bugs/problems, write or call:
'*
'* Rich Geldreich
'* 410 Market St.
'* Gloucester City, NJ 08030
'* (609)-742-8752

DEFINT A-Z

'Procedures in this module:
DECLARE FUNCTION LoadGIF (F$, Vm, ShowType, Xorigin, Yorigin, XScale, YScale)
DECLARE SUB WriteLine ()

'Procedures in SHOWRGB.ASM:
DECLARE SUB ShowRGB (BYVAL PalOffset, BYVAL PalSegment, BYVAL NumColors, BYVAL VGA)

'Procedures in WPIX2.ASM:
DECLARE SUB SetPixels (BYVAL XSkip, A(), BYVAL X, BYVAL Y, BYVAL NumPixels)
DECLARE SUB SetMode (BYVAL Mode)
DECLARE SUB SetWidth (BYVAL ScreenWidth)

'Procedure in RESCALE.ASM:
DECLARE SUB Rescale (A(), B(), BYVAL NumPoints, BYVAL NewScale)

'Procedure in X360x480.ASM:
DECLARE SUB X360x480 ()

CONST True = -1, False = 0

CONST BufferLength = 10000      'change this if desired- but don't
                                'make it too low or floppy-based systems
                                'will suffer(A LOT)
DIM SHARED Pixels(1024)
DIM SHARED PassStep(4), PassStart(4) AS LONG
DIM SHARED ErrorStatus

END
DriveError:
    ErrorStatus = True
RESUME NEXT

'Decompression tables
GIFData:
    'MaxCodes(0 to 11)
    DATA 4,8,16,&h20,&h40,&h80,&h100,&h200,&h400,&h800,&h1000,8192
    'CodeMask(1 to 8)
    DATA 1,3,7,15,31,63,127,255
    'Powers2(0 to 14)
    DATA 1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384

    'PassStep(0 to 3), PassStart(0 to 3)
    DATA 8,8,4,2,0,4,2,1

'******************************************************************************
'* Displays A GIF file.
'*
'* F$ is the filename of the GIF image.
'*
'* Vm is the video mode:
'*    mode 0=320x200x256 vga QB mode 13
'*    mode 1=360x480x256 vga  -non QB-
'*    mode 2=640x480x16  vga QB mode 12
'*    mode 3=320x200x16  ega QB mode 7
'*    mode 4=640x350x16  ega QB mode 9
'* (To use the 360x480x256 mode on a VGA, call the assembly procedure
'* named "X360x480". Don't forget QB doesn't have support for this graphics
'* mode.)
'*
'* ShowType:
'*   0 = Set the palette before the image is decompressed.
'*   1 = Set the palette after the image is decompressed. The entire palette
'*   used by the GIF file will be set to black so the user doesn't see the
'*   image while it is being decompressed.
'*
'* Xorigin, Yorigin:
'*   The origin of the image. If Xorigin=50, and Yorigin=-50, then the
'*   image's upper left corner will be at (50,-50). If the image cannot
'*   be seen then LoadGIF will return with an error.
'*
'* Xscale, Yscale:
'*    Resize parameters. Each parameter is actually divided by 256.
'*    If Xscale=128, and Yscale=512, for example, then the image will
'*    be 1/2 as big horizontally and twice as big vertically. If you want
'*    the image to be normal size, then use 256 for both axis. If a parameter
'*    is -1 then that axis will be shrunk or expanded to fit the screen's size.
'*
'*    Let's say Xscale=-1, and Yscale=300. In this particular case, the image
'*    will fit the screen's horizontal size and will be 300/256 as big
'*    vertically. If the resized image is too small or big then LoadGIF will
'*    return an error.
'*
'* If LoadGIF returns...
'*     0 = The image was decompressed successfully
'*     1 = The specified file could not be found
'*     2 = The specified file is not a GIF file, the GIF file had
'*         had a local colormap, or it had an unrecognized format(maby GIF89a)
'*     3 = The GIF file had too many colors for the specified screen
'*     4 = origin or scale error(if the image was totally out of view,
'*         or it was scaled too small or big, for instance)
'*     5 = An error occured while decompressing the image. The image may
'*         be partly visible, however.
'*
FUNCTION LoadGIF (F$, Vm, ShowType, Xorigin, Yorigin, XScale, YScale)
    DIM Prefix(4096), Suffix(4096), OutCode(1024)
    DIM MaxCodes(12), Powers2(16), CodeMask(8)
    DIM Masks(12)

    SHARED CurrentPixel, CurrentLine&
    SHARED XStart&, YStart&, YEnd&, ScreenY&
    SHARED MaxLength, XStart, ScreenY, StoredXLength
    SHARED PassNumber, Interlaced, Done
    SHARED SkipX, SkipY
    SHARED ArrayOffset

    'used for reading single bytes from GIF file
    DIM ByteBuffer AS STRING * 1

    RESTORE GIFData

    B = 2: FOR A = 1 TO 12: Masks(A) = B - 1: B = B * 2: NEXT
    FOR A = 0 TO 11: READ MaxCodes(A): NEXT
    FOR A = 1 TO 8: READ CodeMask(A): NEXT
    FOR A = 0 TO 14: READ Powers2(A): NEXT

    'get unused file handle
    Handle = FREEFILE

    'add GIF extension of needed
    IF INSTR(F$, ".") = 0 THEN F$ = F$ + ".GIF"

    'see if file is present
    ErrorStatus = False
    ON ERROR GOTO DriveError
    OPEN F$ FOR INPUT AS Handle

    'if not then return with error
    IF ErrorStatus THEN
        ON ERROR GOTO 0
        ErrorStatus = False
        LoadGIF = 1
        CLOSE Handle
        EXIT FUNCTION
    ELSE
        CLOSE Handle
    END IF
    're-open file in binary mode
    OPEN F$ FOR BINARY AS Handle
    ON ERROR GOTO 0
    'just in case it didn't work
    IF ErrorStatus THEN
        ErrorStatus = False
        LoadGIF = 1
        CLOSE Handle
        EXIT FUNCTION
    END IF

    'check to see if it's a GIF87a file
    'one of these days I'll implement the GIF89a stuff...
    A$ = SPACE$(6)
    GET Handle, , A$
    IF A$ <> "GIF87a" THEN
        LoadGIF = 2
        CLOSE Handle
        EXIT FUNCTION
    END IF

    'get total screen length and width
    GET Handle, , TotalX
    GET Handle, , TotalY

    'get number of bits required to represent each pixel
    GET Handle, , ByteBuffer
    A = ASC(ByteBuffer)
    BitsPixel = (A AND 7) + 1
    'check for global color map (if none is present then
    'the default palette, whatever that may be, will be used)

        IF (A AND 128) = 0 THEN
        NoPalette = True
    ELSE
        NoPalette = False
    END IF

    'get background color
    '(the background color is ignored in this version, it's seldom
    'important so no big loss)
    GET Handle, , ByteBuffer
    BackGround = ASC(ByteBuffer)
    GET Handle, , ByteBuffer

    'check to make sure byte 7 of the screen descriptor is 0
    IF ASC(ByteBuffer) <> 0 THEN
        LoadGIF = 2
        CLOSE Handle
        EXIT FUNCTION
    END IF

    'calculate the number of colors in image
    NumColors = Powers2(BitsPixel)
    'check out which video mode the caller wants
    SELECT CASE Vm
    CASE 0
        SetMode 0
        ScreenX& = 320 * 256&
        ScreenY& = 200 * 256&
        VGA = True: MaxColors = 256
    CASE 1
        SetMode 1
        SetWidth 90
        ScreenX& = 360 * 256&
        ScreenY& = 480 * 256&
        VGA = True: MaxColors = 256
    CASE 2
        SetMode 2
        SetWidth 80
        ScreenX& = 640 * 256&
        ScreenY& = 480 * 256&
        VGA = True: MaxColors = 16
    CASE 3
        SetMode 2
        SetWidth 40
        ScreenX& = 320 * 256&
        ScreenY& = 200 * 256&
        VGA = False: MaxColors = 16
    CASE 4
        SetMode 2
        SetWidth 80
        ScreenX& = 640 * 256&
        ScreenY& = 350 * 256&
        VGA = False: MaxColors = 16
    END SELECT

    'if the video mode selected doesn't have enough colors for the
    'image then return with error
    IF NumColors > MaxColors THEN
        LoadGIF = 3
        CLOSE Handle
        EXIT FUNCTION
    END IF


    IF NOT NoPalette THEN 'set the palette if it exists
        PalString$ = STRING$(NumColors * 2 + NumColors, 0)

        IF ShowType <> 0 THEN
            ShowRGB SADD(PalString$), SSEG(PalString$), NumColors, VGA
        END IF

        GET Handle, , PalString$

        IF ShowType = 0 THEN
            ShowRGB SADD(PalString$), SSEG(PalString$), NumColors, VGA
        END IF
    END IF

    'skip by any GIF extension blocks(some GIF's have them, some don't)
    GET Handle, , ByteBuffer
    DO WHILE ByteBuffer <> ","
        'if not an extension block then return with error
        IF ByteBuffer <> "!" THEN
            LoadGIF = 2
            CLOSE Handle
            EXIT FUNCTION
        ELSE
            'skip the function code
            GET Handle, , ByteBuffer
            'skip by function data bytes
            DO
                GET Handle, , ByteBuffer
                BlockLength = ASC(ByteBuffer)
                A$ = SPACE$(BlockLength)
                GET Handle, , A$
            LOOP UNTIL BlockLength = 0
        END IF
        GET Handle, , ByteBuffer
    LOOP

    '*************************************************************************
    '* X/Y Rescaling Setup Routines Start Here
    '* 7-17-92

    'get image start coordinates
    GET Handle, , A: XStart& = A * 256&
    GET Handle, , A: YStart& = A * 256&
    GET Handle, , StoredXLength
    GET Handle, , A

    IF XScale = -1 THEN XScale = ScreenX& \ StoredXLength
    IF YScale = -1 THEN YScale = ScreenY& \ A

    XLength& = StoredXLength * CLNG(XScale)
    YLength& = A * CLNG(YScale)
    IF XScale <= 1 OR YScale <= 0 OR XLength& > 524288 OR YScale > 4095 THEN
        LoadGIF = 4
        CLOSE Handle
        EXIT FUNCTION
    END IF

    XStart& = XStart& + Xorigin * 256&
    YStart& = YStart& + Yorigin * 256&

    IF XStart& < 0 THEN
        ArrayOffset = (-XStart&) \ 256
        XLength& = XLength& + XStart&
        XStart& = 0
    ELSE
        ArrayOffset = 0
    END IF

    XEnd& = XLength& + XStart& - 256
    YEnd& = YLength& + YStart& - 256

    MaxLength = XLength& \ 256
    IF (MaxLength * 256& + XStart& - 256) > ScreenX& THEN
        MaxLength = (ScreenX& - XStart&) \ 256
    END IF

    IF XStart& >= ScreenX& OR YStart& >= ScreenY& OR XEnd& < 0 OR YEnd& < 0 OR MaxLength = 0 THEN
        LoadGIF = 4
        CLOSE Handle
        EXIT FUNCTION
    END IF

    SkipX = 65536 \ XScale
    SkipY = YScale
    XStart = XStart& \ 256
    ScreenY = ScreenY& \ 256

    FOR I = 0 TO 3: READ A: PassStep(I) = A * YScale: NEXT
    FOR I = 0 TO 3: READ A: PassStart(I) = A * YScale + YStart&: NEXT
    '*************************************************************************
    '* X/Y Rescaling Setup Routines End Here
    '*


    'check for local colormap(I'll handle this as soon as I find
    'a GIF that has one!)
    GET Handle, , ByteBuffer: A = ASC(ByteBuffer)
    IF (A AND 128) THEN
        LoadGIF = 2
        CLOSE Handle
        EXIT FUNCTION
    END IF

    'check if interlaced
    IF (A AND 64) THEN
        Interlaced = True
        PassNumber = 0
    ELSE
        Interlaced = False
    END IF

    'get LZW minimum code size
    GET Handle, , ByteBuffer
    CodeSize = ASC(ByteBuffer)

    'when the clear code is received the LZW vars are reset
    ClearCode = Powers2(CodeSize)
    'when EofCode is received the decompressor stops
    EofCode = ClearCode + 1
    'first free code in table
    FirstFree = ClearCode + 2
    FreeCode = FirstFree
    '# bits in code
    CodeSize = CodeSize + 1
    InitCodeSize = CodeSize
    'maximum # of codes for the current codesize
    MaxCode = MaxCodes(CodeSize - 2)
    BitMask = CodeMask(BitsPixel)
    ReadMask = Masks(CodeSize)

    'set up the disk buffer vars
    BitsLeft = 0            'number of bits left(ReadCode)
    BlockLength = 1         'current GIF block length
    Address = 0             'current address in disk buffer
    EndAddress = 1          'address of end of disk buffer

    OutCount = 0            '# of pixels in the psuedo-stack

    CurrentPixel = 0
    CurrentLine& = YStart&

    Done = False

    Buffer$ = SPACE$(BufferLength) 'disk buffer
    CodeErrors = 0: ErrorThreshold = 0  'if CodeErrors>ErrorThreshold then
                                        'the image is assumed to be corrupted
    ERASE Pixels

    DO 'until an error or EOFCode is detected

        'get a code from the data stream- inserted directly into
        'the code to aviod a GOSUB command for each code
    '*************************************************************************

        'GOSUB ReadCode

        'do we have any bits left?
        IF BitsLeft = 0 THEN
            Address = Address + 1
            IF Address = EndAddress THEN GOSUB FillBuffer
            TempChar = PEEK(Address)
            BlockLength = BlockLength - 1
            IF BlockLength = 0 THEN
                BlockLength = TempChar
                Address = Address + 1
                IF Address = EndAddress THEN GOSUB FillBuffer
                TempChar = PEEK(Address)
            END IF
            '8 bits left now
            BitsLeft = 8
        END IF
        'attach bits to workcode&
        WorkCode& = TempChar \ Powers2(8 - BitsLeft)
        'loop while more bits are needed...
        DO WHILE CodeSize > BitsLeft
            'get another byte from buffer
            Address = Address + 1
            'fill up buffer if it's empty
            IF Address = EndAddress THEN GOSUB FillBuffer
            TempChar = PEEK(Address)
            'see if at end of current block
            BlockLength = BlockLength - 1
            IF BlockLength = 0 THEN
                'get another block
                BlockLength = TempChar
                Address = Address + 1
                IF Address = EndAddress THEN GOSUB FillBuffer
                TempChar = PEEK(Address)
            END IF
            'add bits to workcode&
            WorkCode& = WorkCode& OR TempChar * CLNG(Powers2(BitsLeft))
            BitsLeft = BitsLeft + 8
        LOOP
        'update the BitsLeft variable
        BitsLeft = BitsLeft - CodeSize
        'mask off WorkCode&
        Code = WorkCode& AND ReadMask


'*************************************************************************


        'is it an EofCode?
        IF Code <> EofCode THEN
            'check if it's a Clear Code
            IF Code = ClearCode THEN
                'process a clear code; reset LZW vars
                CodeSize = InitCodeSize
                ReadMask = Masks(CodeSize)
                MaxCode = MaxCodes(CodeSize - 2)
                FreeCode = FirstFree
                'first code must be a character
                GOSUB ReadCode
                CurCode = Code
                OldCode = Code
                FinChar = Code AND BitMask
                Pixels(CurrentPixel) = FinChar
                CurrentPixel = CurrentPixel + 1
                IF CurrentPixel = StoredXLength THEN WriteLine
            ELSE
                'process a code
                CurCode = Code
                InCode = Code
                'do we have this string yet?
                IF Code >= FreeCode THEN
                    'Code > FreeCode is invalid: increment CodeErrors and
                    'stop decompression if too many errors(for bum GIF
                    'files)
                    IF Code > FreeCode THEN
                        CodeErrors = CodeErrors + 1
                        IF CodeErrors > ErrorThreshold THEN
                            'trick decompressor into ending early
                            Code = EofCode
                        END IF
                    END IF
                    'trick decompressor into thinking it has just
                    'received the last code
                    CurCode = OldCode
                    OutCode(OutCount) = FinChar
                    OutCount = OutCount + 1
                END IF

                'does this code represent a string?
                IF CurCode > BitMask THEN
                    DO 'until we get the last character in this string
                        OutCode(OutCount) = Suffix(CurCode)
                        CurCode = Prefix(CurCode)
                        OutCount = OutCount + 1
                    LOOP UNTIL CurCode <= BitMask  'LOOP until we have one
                END IF                             'character left

                FinChar = CurCode AND BitMask
                OutCode(OutCount) = FinChar
                'plot the pixels; "pop" each one off the stack
                'when the line buffer is full it will be dumped onto
                'the screen
                FOR I = OutCount TO 0 STEP -1
                    Pixels(CurrentPixel) = OutCode(I)
                    CurrentPixel = CurrentPixel + 1
                    IF CurrentPixel = StoredXLength THEN WriteLine
                NEXT
                'reset the stack
                OutCount = 0

                'enter new string into table
                Prefix(FreeCode) = OldCode
                Suffix(FreeCode) = FinChar
                'remember code for later
                OldCode = InCode
                FreeCode = FreeCode + 1
                'increment code size if needed
                IF FreeCode >= MaxCode AND CodeSize < 12 THEN
                    CodeSize = CodeSize + 1
                    MaxCode = MaxCode * 2
                    ReadMask = ReadMask * 2 OR 1
                END IF
            END IF
        END IF
    'loop until error or done
    LOOP UNTIL Code = EofCode OR ErrorStatus OR Done
    'close file
    CLOSE Handle

    'check for errors
    IF ErrorStatus OR CodeErrors > 0 THEN
        LoadGIF = 5
    ELSE
        IF ShowType = 1 THEN
            ShowRGB SADD(PalString$), SSEG(PalString$), NumColors, VGA
        END IF
        LoadGIF = 0
    END IF
    'all done
    EXIT FUNCTION

'*****************************************************************************
'* Reads one code from the GIF data stream
'* BitsLeft    -  # of bits currently left in TempChar
'* TempChar    -  holds the current byte from buffer
'* Address     -  current address in buffer
'* EndAddress  -  end address of buffer
'* BlockLength -  number of bytes left in current block
'* WorkCode&   -  temporary variable;holds current code
'* If this routine was coded in assembly, the decompression speed of this
'* program would probably increase by 100% or more...
ReadCode:
    'do we have any bits left?
    IF BitsLeft = 0 THEN
        Address = Address + 1
        IF Address = EndAddress THEN GOSUB FillBuffer
        TempChar = PEEK(Address)
        BlockLength = BlockLength - 1
        IF BlockLength = 0 THEN
            BlockLength = TempChar
            Address = Address + 1
            IF Address = EndAddress THEN GOSUB FillBuffer
            TempChar = PEEK(Address)
        END IF
        '8 bits left now
        BitsLeft = 8
    END IF
    'attach bits to workcode&
    WorkCode& = TempChar \ Powers2(8 - BitsLeft)
    'loop while more bits are needed...
    DO WHILE CodeSize > BitsLeft

        Address = Address + 1   'get another byte from buffer

        'fill up buffer if it's empty
        IF Address = EndAddress THEN GOSUB FillBuffer
        TempChar = PEEK(Address)

        BlockLength = BlockLength - 1 'see if at end of current block
        IF BlockLength = 0 THEN
            BlockLength = TempChar 'get another block
            Address = Address + 1
            IF Address = EndAddress THEN GOSUB FillBuffer
            TempChar = PEEK(Address)
        END IF

        'add bits to workcode&
        WorkCode& = WorkCode& OR TempChar * CLNG(Powers2(BitsLeft))
        BitsLeft = BitsLeft + 8
    LOOP

    BitsLeft = BitsLeft - CodeSize 'update the BitsLeft variable
    Code = WorkCode& AND ReadMask  'mask off WorkCode&
RETURN
FillBuffer:
    'fills up the disk buffer

    'turn on error checking for this read
    'if an error is detected then main loop will stop decoding the image

    ON ERROR GOTO DriveError
    GET Handle, , Buffer$
    ON ERROR GOTO 0

    A& = SADD(Buffer$)
    A& = A& - 65536 * (A& < 0)
    DEF SEG = SSEG(Buffer$) + (A& \ 16)
    Address = A& MOD 16

    EndAddress = Address + BufferLength
RETURN

END FUNCTION

SUB WriteLine
    SHARED CurrentPixel, CurrentLine&
    SHARED XStart&, YStart&, YEnd&, ScreenY&
    SHARED MaxLength, XStart, ScreenY, StoredXLength
    SHARED PassNumber, Interlaced, Done
    SHARED SkipX, SkipY
    SHARED ArrayOffset
    DIM ScaledPixels(2047) 'enough to hold 2048 pixels

    Y = CurrentLine& \ 256
    Y1 = (CurrentLine& + SkipY) \ 256
    IF SkipX <> 256 THEN

        Rescale Pixels(), ScaledPixels(), StoredXLength, SkipX

        FOR Y = Y TO Y1 - 1
            IF Y > -1 AND Y < ScreenY THEN
                SetPixels ArrayOffset, ScaledPixels(), XStart, Y, MaxLength
            END IF
        NEXT
    ELSE
        FOR Y = Y TO Y1 - 1
            IF Y > -1 AND Y < ScreenY THEN
                SetPixels ArrayOffset, Pixels(), XStart, Y, MaxLength
            END IF
        NEXT
    END IF

    CurrentPixel = 0
    IF NOT Interlaced THEN
        CurrentLine& = CurrentLine& + SkipY
        IF CurrentLine& >= ScreenY& THEN Done = True
    ELSE
        CurrentLine& = CurrentLine& + PassStep(PassNumber)
        IF CurrentLine& > YEnd& THEN
            PassNumber = PassNumber + 1
            CurrentLine& = PassStart(PassNumber)
        END IF
        IF PassNumber = 3 AND CurrentLine& >= ScreenY& THEN Done = True
    END IF
END SUB